home *** CD-ROM | disk | FTP | other *** search
/ Shareware Extravaganza - Disc 4 / Shareware Extravaganza - Over 25,000 Programs (The Ultimate Shareware Company)(Disc 4 of 4)(1993).iso / cad / cabine.zip / CABINET.LSP < prev   
Text File  |  1990-01-16  |  12KB  |  240 lines
  1. ; FILE NAME: CABINET.LSP
  2. ; Written by: Bob Thomas                
  3. ;             Thomas Enterprises, ltd.  
  4. ;             1030 "B" Street, Suite 201
  5. ;             San Rafael, CA 94901   
  6. ;             415/453-8712
  7. ;
  8. ; This file and its accompanying Release 10 drawing file, CABINET.DWG, may be 
  9. ; freely copied provided that the two files remain together and this header 
  10. ; remains intact, so that people know what the program does and I can get a 
  11. ; free plug in. Thank you.  Use and enjoy...
  12. ;
  13. ; Recommended LISPSTACK=40000   LISPHEAP=5000, or R10 Extended AutoLISP
  14. ;
  15. ; This file contains a parametric program that creates 2D representations of
  16. ; cabinet faces.  All variables are local except those used to set and retain 
  17. ; defaults, as follows (Rename these if they conflict with yours):
  18. ;
  19. ;  bcw   = Cabinet width (24")
  20. ;  bch   = Cabinet height (36")
  21. ;          (72" for linen cabinets, if no height value entered previously)
  22. ;  oset1 = 1st offset (drawer-to-side: 2")
  23. ;  oset2 = 2nd offset (drawer detail: 1")
  24. ;  bth   = Base trim height (4")
  25. ;  bto   = Base trim offset (1")
  26. ;  dc    = Drawer configuration (4)
  27. ;  nd    = Number of drawers (1)
  28. ;
  29. ;  (All values entered become default for repeats.)
  30. ;
  31. ; AutoCAD Command Prompt Sequence:
  32. ;
  33. ; Command: CABINET
  34. ;   Basic/Linen/Wall:                (Select one)
  35. ;   Cabinet width: <default>:        (Enter)
  36. ;   Height <default>:                (Enter)
  37. ;   Base trim height <default>:      (Basic & linen cabinets)
  38. ;   Base trim offset <default>:      (Basic & linen cabinets)
  39. ;   Base cabinet height <default>:   (Linen cabinets only)
  40. ;   1st offset <default>:            (Space btw. drawers and side)
  41. ;   2nd offset <default>:            (Drawer detail offset)
  42. ;   Drawer Configuration <default>:  (Max. number of drawers; determines size)
  43. ;   Number of drawers <default>:     (Actual drawers this cabinet)
  44. ;   Move cabinet into place.         (When outline is drawn, position cabinet)
  45. ;
  46. ;   The accompanying Release 9 drawing file, CABINET.DWG, illustrates the
  47. ;   drawing parameters that correspond to these prompts.
  48. ;
  49. (prompt "\nLoading CABINET.LSP...")
  50. (defun C:CABINET( / c x xbch xbcw xbth xbto xoset1 xoset2 xdc xnd i_pt olderr
  51.   oldblp oldcmd oldort atest gt dipt dcpt fdipt idipt dipt2 dipt3 dipt4 idipt2
  52.   idipt3 idipt4 ss1 ss2 ss3 up down across valid linen basic wall ctype)
  53.    (setq oldblp (getvar "BLIPMODE") oldcmd (getvar "CMDECHO")
  54.          olderr *ERROR* oldort (getvar "ORTHOMODE") down 4.712389 gt " <"
  55.          ss1 (ssadd) x ">: " i_pt (cadr (grread 12)) up 1.570796 c "c"
  56.          basic nil linen nil wall nil valid nil)
  57.    (defun *ERROR* (msg) (princ msg) (setvar "BLIPMODE" oldblp)
  58.      (setvar "CMDECHO" oldcmd) (setvar "ORTHOMODE" oldort)
  59.      (setq *ERROR* olderr) (princ))
  60.    (setvar "BLIPMODE" 0) (setvar "CMDECHO" 0)
  61.    (if (= bth nil)   (setq bth 4))   (if (= bto nil)   (setq bto 1))
  62.    (if (= oset1 nil) (setq oset1 2)) (if (= oset2 nil) (setq oset2 1))
  63.    (if (= dc nil)    (setq dc 4))    (if (= nd nil)    (setq nd 1))
  64.    (if (= bcw nil)   (setq bcw 24))  (if (= bbch nil)  (setq bbch 36))
  65.    (while (and (not basic) (not linen) (not wall))
  66.      (setq ctype (strcase (substr (getstring "Basic/Linen/Wall: ") 1 1)))
  67.      (cond ((= ctype "B") (setq basic T)) ((= ctype "L") (setq linen T))
  68.            ((= ctype "W") (setq wall T))))
  69.    (if (and (= bch nil) (/= ctype "L")) (setq bch 36))
  70.    (if (and (= bch nil) (= ctype "L")) (setq bch 72))
  71.    (if (= ctype "L") (setq linen T) (setq linen nil))
  72.    (while (not valid)
  73.     (setq xbcw (getdist (strcat "\nCabinet width" gt (rtos bcw) x)))
  74.     (if (or (= xbcw nil) (= xbcw "")) (eval nil) (setq bcw xbcw))
  75.     (setq xbch (getdist (strcat "\nHeight" gt (rtos bch) x)))
  76.     (if (or (= xbch nil) (= xbch "")) (eval nil) (setq bch xbch))
  77.     (if (not wall) (progn
  78.       (setq xbth (getdist (strcat "\nBase trim height" gt (rtos bth) x)))
  79.       (if (or (= xbth nil) (= xbth "")) (eval nil) (setq bth xbth))
  80.       (setq xbto (getdist (strcat "\nBase trim offset" gt (rtos bto) x)))
  81.       (if (or (= xbto nil) (= xbto "")) (eval nil) (setq bto xbto))))
  82.       (setq xoset1 (getdist (strcat "\n1st offset" gt (rtos oset1) x)))
  83.       (if (or (= xoset1 nil) (= xoset1 "")) (eval nil) (setq oset1 xoset1))
  84.       (setq xoset2 (getdist (strcat "\n2nd offset" gt (rtos oset2) x)))
  85.       (if (or (= xoset2 nil) (= xoset2 "")) (eval nil) (setq oset2 xoset2))
  86.       (if linen (progn
  87.        (setq xbbch (getdist (strcat "\nBase cabinet height" gt (rtos bbch) x)))
  88.        (if (or (not xbbch) (= xbbch "")) (eval nil) (setq bbch xbbch))))
  89.       (if wall (setq valid T) (progn
  90.        (setq xdc (getint (strcat "\nDrawer configuration" gt (rtos dc 2 0) x)))
  91.        (if (or (= xdc nil) (= xdc "")) (eval nil) (setq dc xdc))
  92.         (setq xnd (getint (strcat "\nNumber of drawers" gt (rtos nd 2 0) x)))
  93.         (if (or (= xnd nil) (= xnd "")) (eval nil) (setq nd xnd))
  94.         (setq dtest 1 across 1 atest 1)
  95.         (if (= linen T)
  96.            (setq dcw (- bcw (* 2 oset1))
  97.                  dch (- (- bch (* 2 oset1)) bth)
  98.                  dh  (/ (- dch (+ bbch (* oset1 dc))) (float dc))
  99.                  fdh (+ (* dh (- dc nd)) (* oset1 (1- (- dc nd)))))
  100.            (setq dcw (- bcw (* 2 oset1))
  101.                  dch (- (- bch (* 2 oset1)) bth)
  102.                  dh  (/ (- dch (* oset1 (1- dc))) (float dc))
  103.                  fdh (+ (* dh (- dc nd)) (* oset1 (1- (- dc nd))))))
  104.         (if (< dh 0)
  105.          (prompt (strcat "\nImpossible cabinet. Drawer: " (rtos dh 2 0)))
  106.          (progn (prompt "\nProcessing. One moment...") (setq valid T))))))
  107.    (if (not wall) (progn
  108.        (while (> dcw 24)
  109.           (setq across (1+ across)
  110.                 dcw (/ (- bcw (* oset1 (1+ across))) (float across))))
  111.        (command "pline" i_pt "w" 0 0 (polar i_pt up bch)
  112.                 (polar (getvar "LASTPOINT") 0 bcw)
  113.                 (polar (getvar "LASTPOINT") down bch) c)
  114.        (setq ss1 (ssadd (entlast)))
  115.        (command "line" (polar i_pt up bth) 
  116.                 (polar (getvar "LASTPOINT") 0 bcw) "")
  117.        (setq ss1 (ssadd (entlast) ss1))
  118.        (command "line" (polar i_pt up (- bth bto)) 
  119.                 (polar (getvar "LASTPOINT") 0 bcw) "")
  120.        (setq ss1 (ssadd (entlast) ss1))
  121.        (setvar "ORTHOMODE" 0)
  122.        (prompt "\nMove cabinet into place.")
  123.        (command "move" ss1 "" i_pt pause)
  124.        (setq i_pt2 (getvar "lastpoint")
  125.              dipt (polar (polar (polar i_pt2 up bch) 0 oset1) down oset1))
  126.        (if basic (setq dcpt (polar dipt down (+ dh oset1))))
  127.          (if linen (progn
  128.             (command "pline" dipt (setq dipt2 (polar dipt 0 dcw))
  129.                      (setq dipt3 (polar dipt2 down bbch))
  130.                      (setq dipt4 (polar dipt3 pi dcw)) c)
  131.             (setq ss3 (ssadd (entlast)))
  132.             (command "pline" (setq idipt (polar (polar dipt 0 oset2) 
  133.                                                 down oset2))
  134.                      (setq idipt2 (polar idipt 0 (- dcw (* oset2 2))))
  135.                      (setq idipt3 (polar idipt2 down (- bbch (* oset2 2))))
  136.                      (setq idipt4 (polar idipt3 pi (- dcw (* oset2 2)))) c)
  137.             (setq ss3 (ssadd (entlast) ss3))
  138.             (command "line" dipt idipt "")
  139.             (setq ss3 (ssadd (entlast) ss3))
  140.             (command "line" dipt2 idipt2 "")
  141.             (setq ss3 (ssadd (entlast) ss3))
  142.             (command "line" dipt3 idipt3 "")
  143.             (setq ss3 (ssadd (entlast) ss3))
  144.             (command "line" dipt4 idipt4 "")
  145.             (setq ss3 (ssadd (entlast) ss3))
  146.             (setq udipt dipt
  147.                   dipt (polar dipt down (+ bbch oset1))
  148.                   dcpt (polar dipt down (+ dh oset1)))))
  149.          (command "pline" dipt (setq dipt2 (polar dipt 0 dcw))
  150.                   (setq dipt3 (polar dipt2 down dh))
  151.                   (setq dipt4 (polar dipt3 pi dcw)) c)
  152.          (setq ss1 (ssadd (entlast)))
  153.          (command "pline" (setq idipt (polar (polar dipt 0 oset2) down oset2))
  154.                   (setq idipt2 (polar idipt 0 (- dcw (* oset2 2))))
  155.                   (setq idipt3 (polar idipt2 down (- dh (* oset2 2))))
  156.                   (setq idipt4 (polar idipt3 pi (- dcw (* oset2 2)))) c)        
  157.          (setq ss1 (ssadd (entlast) ss1))
  158.          (command "line" dipt idipt "")
  159.          (setq ss1 (ssadd (entlast) ss1))
  160.          (command "line" dipt2 idipt2 "")
  161.          (setq ss1 (ssadd (entlast) ss1))
  162.          (command "line" dipt3 idipt3 "")
  163.          (setq ss1 (ssadd (entlast) ss1))
  164.          (command "line" dipt4 idipt4 "")
  165.          (setq ss1 (ssadd (entlast) ss1))
  166.          (while (< dtest nd)
  167.              (command "copy" ss1 "" dipt dcpt)
  168.              (setq dtest (1+ dtest) dcpt (polar dcpt down (+ dh oset1))))
  169.              (if (< nd dc) (progn
  170.                (setq fdipt dcpt)
  171.                (command "pline" dcpt (setq dipt2 (polar dcpt 0 dcw))
  172.                       (setq dipt3 (polar dipt2 down fdh))
  173.                       (setq dipt4 (polar dipt3 pi dcw)) c)
  174.                       (setq ss2 (ssadd (entlast)))
  175.                (command "pline" (setq idipt (polar (polar dcpt 0 oset2) 
  176.                                                 down oset2))
  177.                       (setq idipt2 (polar idipt 0 (- dcw (* oset2 2))))
  178.                       (setq idipt3 (polar idipt2 down (- fdh (* oset2 2))))
  179.                       (setq idipt4 (polar idipt3 pi (- dcw (* oset2 2)))) c)
  180.                (setq ss2 (ssadd (entlast) ss2))
  181.                (command "line" dcpt idipt "")
  182.                (setq ss2 (ssadd (entlast) ss2))
  183.                (command "line" dipt2 idipt2 "")
  184.                (setq ss2 (ssadd (entlast) ss2))
  185.                (command "line" dipt3 idipt3 "")
  186.                (setq ss2 (ssadd (entlast) ss2))
  187.                (command "line" dipt4 idipt4 "")
  188.                (setq ss2 (ssadd (entlast) ss2))))
  189.          (while (< atest across)
  190.             (if linen (progn
  191.                (setq dcpt (polar udipt 0 (* (+ dcw oset1) atest)))
  192.                (command "copy" ss3 "" udipt dcpt)))
  193.             (setq dcpt (polar dipt 0 (* (+ dcw oset1) atest))
  194.                   atest (1+ atest) dtest 1)
  195.             (while (<= dtest nd)
  196.                (command "copy" ss1 "" dipt dcpt)
  197.                (setq dtest (1+ dtest) dcpt (polar dcpt down (+ dh oset1))))
  198.             (if (< nd dc) (progn
  199.                (setq dcpt (polar fdipt 0 (* (+ dcw oset1) (1- atest))))
  200.                (command "copy" ss2 "" fdipt dcpt)))))
  201.       (progn
  202.          (command "pline" i_pt "w" 0 0 (polar i_pt 0 bcw)
  203.             (polar (getvar "LASTPOINT") down bch)
  204.             (polar (getvar "LASTPOINT") pi bcw) c)
  205.          (setq ss1 (ssadd (entlast))
  206.                h (- bch (* oset1 2))
  207.                w (- bcw (* oset1 2)))
  208.          (command "pline" (setq dipt (polar (polar i_pt 0 oset1) down oset1))
  209.             (setq dipt2 (polar dipt 0 w)) (setq dipt3 (polar dipt2 down h))
  210.             (setq dipt4 (polar dipt3 pi w)) c)
  211.          (setq ss1 (ssadd (entlast) ss1)
  212.                h (- h (* oset2 2))
  213.                w (- w (* oset2 2)))
  214.          (command "pline" (setq idipt (polar (polar i_pt 0 (+ oset1 oset2))
  215.                                              down (+ oset1 oset2)))
  216.                   (setq idipt2 (polar idipt 0 w))
  217.                   (setq idipt3 (polar idipt2 down h))
  218.                   (setq idipt4 (polar idipt3 pi w)) c)
  219.          (setq ss1 (ssadd (entlast) ss1))
  220.          (command "line" dipt idipt "")
  221.          (setq ss1 (ssadd (entlast) ss1))
  222.          (command "line" dipt2 idipt2 "")
  223.          (setq ss1 (ssadd (entlast) ss1))
  224.          (command "line" dipt3 idipt3 "")
  225.          (setq ss1 (ssadd (entlast) ss1))
  226.          (command "line" dipt4 idipt4 "")
  227.          (setq ss1 (ssadd (entlast) ss1))
  228.          (setvar "ORTHOMODE" 0)
  229.          (prompt "\nMove cabinet into place.")
  230.          (command "move" ss1 "" i_pt pause)))
  231.    (setvar "BLIPMODE" oldblp)
  232.    (setvar "CMDECHO" oldcmd)
  233.    (setvar "ORTHOMODE" oldort)
  234.    (setq *ERROR* olderr)
  235.    (prompt "\nCabinet complete.")
  236.    (princ))
  237. (prompt "Loaded.\n")
  238. (princ)
  239. ; EOF:   Cabinet.LSP     239 lines      Bob Thomas
  240.